(defun schemestart nargs
       (sstatus toplevel '(schemestart1))
       (nointerrupt nil)
       (↑g))

(defun schemestart1 ()
       (sstatus toplevel nil)
       (cursorpos 'c)
       (scheme))

(cond ((status feature newio)
       (sstatus ttyint '/≡ 'schemestart))
      (t (sstatus interrupt 16. 'schemestart)))

(declare (read))
(sstatus macro /% '(lambda ()()))
(declare (sstatus macro /% '(lambda () ((lambda (/%) (eval /%) /%) (read)))) )

(declare (mapex t) (macros t))

;first, some useful macros.

(declare (setq displace nil) (special displace))
%
(defun displace (x y)
   (cond (displace (rplaca x (car y)) (rplacd x (cdr y)) x)
	 (t y)) )

(setq displace t)

%
(defun qexpander (m)
       (prog (x y)
	     (cond ((atom m) (return (list 'quote m)))
		   ((eq (car m) '/,) (return (cdr m)))
		   ((and (not (atom (car m)))
			 (eq (caar m) '/@))
		    (return (list 'append (cdar m) (qexpander (cdr m))))))
	     (setq x (qexpander (car m))
		   y (qexpander (cdr m)))
	     (and (not (atom x))
		  (not (atom y))
		  (eq (car x) 'quote)
		  (eq (car y) 'quote)
		  (eq (cadr x) (car m))
		  (eq (cadr y) (cdr m))
		  (return (list 'quote m)))
	     (return (list 'cons x y))))

%(defun qmac () (qexpander (read)))
%(defun cmac () (cons '/, (read)))
%(defun amac () (cons '/@ (read)))

(*array 'schemeread 'readtable)
((lambda (readtable)
         %(sstatus macro /" 'qmac)
         %(sstatus macro /, 'cmac)
         %(sstatus macro /@ 'amac))
 (get 'schemeread 'array))
(setq readtable (get 'schemeread 'array))

(defprop do ado amacro)

(defun ado (x)
   (displace x
      "(labels ((,doname
                  (lambda (,dobody @(mapcar 'car (cadr x)))
                          (if ,(caaddr x) ,(blockify (cdaddr x))
                              (,doname ,(blockify (cdddr x))
                                       @(mapcar '(lambda (y)
							 (cond ((and (cdr y) (cddr y))
								(caddr y))
							       (t (car y))))
						(cadr x)))))))
          (,doname nil @(mapcar '(lambda (y) (and (cdr y) (cadr y))) (cadr x))))))

(setq doname (maknam (explodec '*doloop*)))
(setq dobody (maknam (explodec '*dobody*)))

(defprop cond acond amacro)

(defun acond (x)
       (cond ((null (cdr x)) (error '|Peculiar Cond| x 'fail-act))
	     (t (displace x (acond1 (cdr x))))))

(defun acond1 (x)
      (cond ((null x) nil)
            ((eq (caar x) 't) (blockify (cdar x)))
	    ((eq (cadar x) '=>)
	     "(test ,(caar x) ,(caddar x)
		     ,(acond1 (cdr x))))
            (t "(if ,(caar x) ,(blockify (cdar x))
                    ,(acond1 (cdr x))))))

(defprop block ablock amacro)

(defun ablock (x)
       (cond ((or (null (cdr x))
                  (null (cddr x)))
              (error '|Peculiar Block| x 'fail-act))
             (t (displace x
                    "((lambda (@(mapcar '(lambda (x) '**a**) (cddr x)) **b**) (**b**))
                      @(nreverse (cdr (reverse (cdr x)))) (lambda () ,(car (last x))))))))

(defun blockify (x)
       (cond ((null x) nil)
             ((null (cdr x)) (car x))
             (t "(block @x))))

(defprop and aand amacro)

(defun aand (x)
       (displace x (cond ((or (null (cdr x))
			      (null (cddr x)))
			  (error '|Peculiar And| x 'wrng-no-args))
			 (t (aand1 (cdr x))))))

(defun aand1 (x)
       (cond ((null (cdr x)) (car x))
	     (t "(if ,(car x) ,(aand1 (cdr x)) nil))))

(defprop or aor amacro)

(defun aor (x)
       (displace x (cond ((or (null (cdr x))
			      (null (cddr x)))
			  (error '|Peculiar Or| x 'wrng-no-args))
			 (t (aor1 (cdr x))))))

(defun aor1 (x)
       (cond ((null (cdr x)) (car x))
	     (t "(test ,(car x)
		       (lambda (x) x)
		       ,(aor1 (cdr x))))))

(defun orify (x)
       (cond ((null x) nil)
	     ((null (cdr x)) (car x))
	     (t (cons 'or x))))

(defprop amapcar amapcar1 amacro)

(defun amapcar1 (x)
       (cond ((null (cddr x))
	      (error '|Peculiar Amapcar| x 'wrng-no-args))
	     (t ((lambda (names)
		     (displace x
			 "(do ((,(car names)
				nil
				(cons (,(cadr x) @(mapcar '(lambda (y) "(car ,y))
							   (cdr names)))
				      ,(car names)))
			       @(mapcar '(lambda (y n) "(,n ,y (cdr ,n)))
					 (cddr x)
					 (cdr names)))
			      (,(orify (mapcar '(lambda (n) "(null ,n)) (cdr names)))
			       (nreverse ,(car names))))))
		 (do ((z (cdr x) (cdr z))
		      (n nil (cons (gensym) n)))
		     ((null z) n))))))

(defprop amaplist amaplist1 amacro)

(defun amaplist1 (x)
       (cond ((null (cddr x))
	      (error '|Peculiar Amaplist| x 'wrng-no-args))
	     (t ((lambda (names)
		     (displace x
			 "(do ((,(car names)
				nil
				(cons (,(cadr x) @(cdr names)) ,(car names)))
			       @(mapcar '(lambda (y n) "(,n ,y (cdr ,n)))
					 (cddr x)
					 (cdr names)))
			      (,(orify (mapcar '(lambda (n) "(null ,n)) (cdr names)))
			       (nreverse ,(car names))))))
		 (do ((z (cdr x) (cdr z))
		      (n nil (cons (gensym) n)))
		     ((null z) n))))))

(defprop uread afsubr amacro)
(defprop uwrite afsubr amacro)
(defprop ufile afsubr amacro)
(defprop grindef afsubr amacro)
(defprop fasload afsubr amacro)
(defprop edit afsubr amacro)
(defprop status afsubr amacro)
(defprop sstatus afsubr amacro)
(defprop setq afsubr amacro)
(defprop defun afsubr amacro)

(defun afsubr (x) "(eval ',x))

ββ